home *** CD-ROM | disk | FTP | other *** search
/ Compendium Deluxe 2 / LSD and 17bit Compendium Deluxe - Volume II.iso / a / prog / cprog / f2c3.2src.lha / f2c-for-SASC651 / src / vax.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-06-29  |  11.5 KB  |  554 lines
  1. /****************************************************************
  2. Copyright 1990, 1992, 1993, 1994 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. #include "defs.h"
  25. #include "pccdefs.h"
  26. #include "output.h"
  27.  
  28. int regnum[] =  {
  29.     11, 10, 9, 8, 7, 6 };
  30.  
  31. /* Put out a constant integer */
  32.  
  33.  void
  34. #ifdef KR_headers
  35. prconi(fp, n)
  36.     FILEP fp;
  37.     ftnint n;
  38. #else
  39. prconi(FILEP fp, ftnint n)
  40. #endif
  41. {
  42.     fprintf(fp, "\t%ld\n", n);
  43. }
  44.  
  45.  
  46.  
  47. /* Put out a constant address */
  48.  
  49.  void
  50. #ifdef KR_headers
  51. prcona(fp, a)
  52.     FILEP fp;
  53.     ftnint a;
  54. #else
  55. prcona(FILEP fp, ftnint a)
  56. #endif
  57. {
  58.     fprintf(fp, "\tL%ld\n", a);
  59. }
  60.  
  61.  
  62.  void
  63. #ifdef KR_headers
  64. prconr(fp, x, k)
  65.     FILEP fp;
  66.     Constp x;
  67.     int k;
  68. #else
  69. prconr(FILEP fp, Constp x, int k)
  70. #endif
  71. {
  72.     char *x0, *x1;
  73.     char cdsbuf0[64], cdsbuf1[64];
  74.  
  75.     if (k > 1) {
  76.         if (x->vstg) {
  77.             x0 = x->Const.cds[0];
  78.             x1 = x->Const.cds[1];
  79.             }
  80.         else {
  81.             x0 = cds(dtos(x->Const.cd[0]), cdsbuf0);
  82.             x1 = cds(dtos(x->Const.cd[1]), cdsbuf1);
  83.             }
  84.         fprintf(fp, "\t%s %s\n", x0, x1);
  85.         }
  86.     else
  87.         fprintf(fp, "\t%s\n", x->vstg ? x->Const.cds[0]
  88.                 : cds(dtos(x->Const.cd[0]), cdsbuf0));
  89. }
  90.  
  91.  
  92.  char *
  93. #ifdef KR_headers
  94. memname(stg, mem)
  95.     int stg;
  96.     long mem;
  97. #else
  98. memname(int stg, long mem)
  99. #endif
  100. {
  101.     static char s[20];
  102.  
  103.     switch(stg)
  104.     {
  105.     case STGCOMMON:
  106.     case STGEXT:
  107.         sprintf(s, "_%s", extsymtab[mem].cextname);
  108.         break;
  109.  
  110.     case STGBSS:
  111.     case STGINIT:
  112.         sprintf(s, "v.%ld", mem);
  113.         break;
  114.  
  115.     case STGCONST:
  116.         sprintf(s, "L%ld", mem);
  117.         break;
  118.  
  119.     case STGEQUIV:
  120.         sprintf(s, "q.%ld", mem+eqvstart);
  121.         break;
  122.  
  123.     default:
  124.         badstg("memname", stg);
  125.     }
  126.     return(s);
  127. }
  128.  
  129. /* make_int_expr -- takes an arbitrary expression, and replaces all
  130.    occurrences of arguments with indirection */
  131.  
  132.  expptr
  133. #ifdef KR_headers
  134. make_int_expr(e)
  135.     expptr e;
  136. #else
  137. make_int_expr(expptr e)
  138. #endif
  139. {
  140.     if (e != ENULL)
  141.     switch (e -> tag) {
  142.         case TADDR:
  143.             if (e -> addrblock.vstg == STGARG
  144.          && !e->addrblock.isarray)
  145.             e = mkexpr (OPWHATSIN, e, ENULL);
  146.             break;
  147.         case TEXPR:
  148.             e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp);
  149.             e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp);
  150.             break;
  151.         default:
  152.             break;
  153.     } /* switch */
  154.  
  155.     return e;
  156. } /* make_int_expr */
  157.  
  158.  
  159.  
  160. /* prune_left_conv -- used in prolog() to strip type cast away from
  161.    left-hand side of parameter adjustments.  This is necessary to avoid
  162.    error messages from cktype() */
  163.  
  164.  expptr
  165. #ifdef KR_headers
  166. prune_left_conv(e)
  167.     expptr e;
  168. #else
  169. prune_left_conv(expptr e)
  170. #endif
  171. {
  172.     struct Exprblock *leftp;
  173.  
  174.     if (e && e -> tag == TEXPR && e -> exprblock.leftp &&
  175.         e -> exprblock.leftp -> tag == TEXPR) {
  176.     leftp = &(e -> exprblock.leftp -> exprblock);
  177.     if (leftp -> opcode == OPCONV) {
  178.         e -> exprblock.leftp = leftp -> leftp;
  179.         free ((charptr) leftp);
  180.     }
  181.     }
  182.  
  183.     return e;
  184. } /* prune_left_conv */
  185.  
  186.  
  187.  static int wrote_comment;
  188.  static FILE *comment_file;
  189.  
  190.  static void
  191. write_comment(Void)
  192. {
  193.     if (!wrote_comment) {
  194.         wrote_comment = 1;
  195.         nice_printf (comment_file, "/* Parameter adjustments */\n");
  196.         }
  197.     }
  198.  
  199.  static int *
  200. count_args(Void)
  201. {
  202.     register int *ac;
  203.     register chainp cp;
  204.     register struct Entrypoint *ep;
  205.     register Namep q;
  206.  
  207.     ac = (int *)ckalloc(nallargs*sizeof(int));
  208.  
  209.     for(ep = entries; ep; ep = ep->entnextp)
  210.         for(cp = ep->arglist; cp; cp = cp->nextp)
  211.             if (q = (Namep)cp->datap)
  212.                 ac[q->argno]++;
  213.     return ac;
  214.     }
  215.  
  216.  static int nu, *refs, *used;
  217.  static void awalk Argdcl((expptr));
  218.  
  219.  static void
  220. #ifdef KR_headers
  221. aawalk(P)
  222.     struct Primblock *P;
  223. #else
  224. aawalk(struct Primblock *P)
  225. #endif
  226. {
  227.     chainp p;
  228.     expptr q;
  229.  
  230.     for(p = P->argsp->listp; p; p = p->nextp) {
  231.         q = (expptr)p->datap;
  232.         if (q->tag != TCONST)
  233.             awalk(q);
  234.         }
  235.     if (P->namep->vtype == TYCHAR) {
  236.         if (q = P->fcharp)
  237.             awalk(q);
  238.         if (q = P->lcharp)
  239.             awalk(q);
  240.         }
  241.     }
  242.  
  243.  static void
  244. #ifdef KR_headers
  245. afwalk(P)
  246.     struct Primblock *P;
  247. #else
  248. afwalk(struct Primblock *P)
  249. #endif
  250. {
  251.     chainp p;
  252.     expptr q;
  253.     Namep np;
  254.  
  255.     for(p = P->argsp->listp; p; p = p->nextp) {
  256.         q = (expptr)p->datap;
  257.         switch(q->tag) {
  258.           case TPRIM:
  259.             np = q->primblock.namep;
  260.             if (np->vknownarg)
  261.                 if (!refs[np->argno]++)
  262.                     used[nu++] = np->argno;
  263.             if (q->primblock.argsp == 0) {
  264.                 if (q->primblock.namep->vclass == CLPROC
  265.                  && q->primblock.namep->vprocclass
  266.                         != PTHISPROC
  267.                  || q->primblock.namep->vdim != NULL)
  268.                     continue;
  269.                 }
  270.           default:
  271.             awalk(q);
  272.             /* no break */
  273.           case TCONST:
  274.             continue;
  275.           }
  276.         }
  277.     }
  278.  
  279.  static void
  280. #ifdef KR_headers
  281. awalk(e)
  282.     expptr e;
  283. #else
  284. awalk(expptr e)
  285. #endif
  286. {
  287.     Namep np;
  288.  top:
  289.     if (!e)
  290.         return;
  291.     switch(e->tag) {
  292.       default:
  293.         badtag("awalk", e->tag);
  294.       case TCONST:
  295.       case TERROR:
  296.       case TLIST:
  297.         return;
  298.       case TADDR:
  299.         if (e->addrblock.uname_tag == UNAM_NAME) {
  300.             np = e->addrblock.user.name;
  301.             if (np->vknownarg && !refs[np->argno]++)
  302.                 used[nu++] = np->argno;
  303.             }
  304.         e = e->addrblock.memoffset;
  305.         goto top;
  306.       case TPRIM:
  307.         np = e->primblock.namep;
  308.         if (np->vknownarg && !refs[np->argno]++)
  309.             used[nu++] = np->argno;
  310.         if (e->primblock.argsp && np->vclass != CLVAR)
  311.             afwalk((struct Primblock *)e);
  312.         else
  313.             aawalk((struct Primblock *)e);
  314.         return;
  315.       case TEXPR:
  316.         awalk(e->exprblock.rightp);
  317.         e = e->exprblock.leftp;
  318.         goto top;
  319.       }
  320.     }
  321.  
  322.  static chainp
  323. #ifdef KR_headers
  324. argsort(p0)
  325.     chainp p0;
  326. #else
  327. argsort(chainp p0)
  328. #endif
  329. {
  330.     Namep *args, q, *stack;
  331.     int i, nargs, nout, nst;
  332.     chainp *d, *da, p, rv, *rvp;
  333.     struct Dimblock *dp;
  334.  
  335.     if (!p0)
  336.         return p0;
  337.     for(nargs = 0, p = p0; p; p = p->nextp)
  338.         nargs++;
  339.     args = (Namep *)ckalloc(i = nargs*(sizeof(Namep) + 2*sizeof(chainp)
  340.             + 2*sizeof(int)));
  341.     memset((char *)args, 0, i);
  342.     stack = args + nargs;
  343.     d = (chainp *)(stack + nargs);
  344.     refs = (int *)(d + nargs);
  345.     used = refs + nargs;
  346.  
  347.     for(p = p0; p; p = p->nextp) {
  348.         q = (Namep) p->datap;
  349.         args[q->argno] = q;
  350.         }
  351.     for(p = p0; p; p = p->nextp) {
  352.         q = (Namep) p->datap;
  353.         if (!(dp = q->vdim))
  354.             continue;
  355.         i = dp->ndim;
  356.         while(--i >= 0)
  357.             awalk(dp->dims[i].dimexpr);
  358.         awalk(dp->basexpr);
  359.         while(nu > 0) {
  360.             refs[i = used[--nu]] = 0;
  361.             d[i] = mkchain((char *)q, d[i]);
  362.             }
  363.         }
  364.     for(i = nst = 0; i < nargs; i++)
  365.         for(p = d[i]; p; p = p->nextp)
  366.             refs[((Namep)p->datap)->argno]++;
  367.     while(--i >= 0)
  368.         if (!refs[i])
  369.             stack[nst++] = args[i];
  370.     if (nst == nargs) {
  371.         rv = p0;
  372.         goto done;
  373.         }
  374.     nout = 0;
  375.     rv = 0;
  376.     rvp = &rv;
  377.     while(nst > 0) {
  378.         nout++;
  379.         q = stack[--nst];
  380.         *rvp = p = mkchain((char *)q, CHNULL);
  381.         rvp = &p->nextp;
  382.         da = d + q->argno;
  383.         for(p = *da; p; p = p->nextp)
  384.             if (!--refs[(q = (Namep)p->datap)->argno])
  385.                 stack[nst++] = q;
  386.         frchain(da);
  387.         }
  388.     if (nout < nargs)
  389.         for(i = 0; i < nargs; i++)
  390.             if (refs[i]) {
  391.                 q = args[i];
  392.                 errstr("Can't adjust %.38s correctly\n\
  393.     due to dependencies among arguments.",
  394.                     q->fvarname);
  395.                 *rvp = p = mkchain((char *)q, CHNULL);
  396.                 rvp = &p->nextp;
  397.                 frchain(d+i);
  398.                 }
  399.  done:
  400.     free((char *)args);
  401.     return rv;
  402.     }
  403.  
  404.  void
  405. #ifdef KR_headers
  406. prolog(outfile, p)
  407.     FILE *outfile;
  408.     register chainp p;
  409. #else
  410. prolog(FILE *outfile, register chainp p)
  411. #endif
  412. {
  413.     int addif, addif0, i, nd, size;
  414.     int *ac;
  415.     register Namep q;
  416.     register struct Dimblock *dp;
  417.     chainp p0, p1;
  418.  
  419.     if(procclass == CLBLOCK)
  420.         return;
  421.     p0 = p;
  422.     p1 = p = argsort(p);
  423.     wrote_comment = 0;
  424.     comment_file = outfile;
  425.     ac = 0;
  426.  
  427. /* Compute the base addresses and offsets for the array parameters, and
  428.    assign these values to local variables */
  429.  
  430.     addif = addif0 = nentry > 1;
  431.     for(; p ; p = p->nextp)
  432.     {
  433.         q = (Namep) p->datap;
  434.         if(dp = q->vdim)    /* if this param is an array ... */
  435.         {
  436.         expptr Q, expr;
  437.  
  438.         /* See whether to protect the following with an if. */
  439.         /* This only happens when there are multiple entries. */
  440.  
  441.         nd = dp->ndim - 1;
  442.         if (addif0) {
  443.             if (!ac)
  444.                 ac = count_args();
  445.             if (ac[q->argno] == nentry)
  446.                 addif = 0;
  447.             else if (dp->basexpr
  448.                     || dp->baseoffset->constblock.Const.ci)
  449.                 addif = 1;
  450.             else for(addif = i = 0; i <= nd; i++)
  451.                 if (dp->dims[i].dimexpr
  452.                 && (i < nd || !q->vlastdim)) {
  453.                     addif = 1;
  454.                     break;
  455.                     }
  456.             if (addif) {
  457.                 write_comment();
  458.                 nice_printf(outfile, "if (%s) {\n", /*}*/
  459.                         q->cvarname);
  460.                 next_tab(outfile);
  461.                 }
  462.             }
  463.         for(i = 0 ; i <= nd; ++i)
  464.  
  465. /* Store the variable length of each dimension (which is fixed upon
  466.    runtime procedure entry) into a local variable */
  467.  
  468.             if ((Q = dp->dims[i].dimexpr)
  469.             && (i < nd || !q->vlastdim)) {
  470.             expr = (expptr)cpexpr(Q);
  471.             write_comment();
  472.             out_and_free_statement (outfile, mkexpr (OPASSIGN,
  473.                 fixtype(cpexpr(dp->dims[i].dimsize)), expr));
  474.             } /* if dp -> dims[i].dimexpr */
  475.  
  476. /* size   will equal the size of a single element, or -1 if the type is
  477.    variable length character type */
  478.  
  479.         size = typesize[ q->vtype ];
  480.         if(q->vtype == TYCHAR)
  481.             if( ISICON(q->vleng) )
  482.             size *= q->vleng->constblock.Const.ci;
  483.             else
  484.             size = -1;
  485.  
  486.         /* Fudge the argument pointers for arrays so subscripts
  487.          * are 0-based. Not done if array bounds are being checked.
  488.          */
  489.         if(dp->basexpr) {
  490.  
  491. /* Compute the base offset for this procedure */
  492.  
  493.             write_comment();
  494.             out_and_free_statement (outfile, mkexpr (OPASSIGN,
  495.                 cpexpr(fixtype(dp->baseoffset)),
  496.                 cpexpr(fixtype(dp->basexpr))));
  497.         } /* if dp -> basexpr */
  498.  
  499.         if(! checksubs) {
  500.             if(dp->basexpr) {
  501.             expptr tp;
  502.  
  503. /* If the base of this array has a variable adjustment ... */
  504.  
  505.             tp = (expptr) cpexpr (dp -> baseoffset);
  506.             if(size < 0 || q -> vtype == TYCHAR)
  507.                 tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng));
  508.  
  509.             write_comment();
  510.             tp = mkexpr (OPMINUSEQ,
  511.                 mkconv (TYADDR, (expptr)p->datap),
  512.                 mkconv(TYINT, fixtype
  513.                 (fixtype (tp))));
  514. /* Avoid type clash by removing the type conversion */
  515.             tp = prune_left_conv (tp);
  516.             out_and_free_statement (outfile, tp);
  517.             } else if(dp->baseoffset->constblock.Const.ci != 0) {
  518.  
  519. /* if the base of this array has a nonzero constant adjustment ... */
  520.  
  521.             expptr tp;
  522.  
  523.             write_comment();
  524.             if(size > 0 && q -> vtype != TYCHAR) {
  525.                 tp = prune_left_conv (mkexpr (OPMINUSEQ,
  526.                     mkconv (TYADDR, (expptr)p->datap),
  527.                     mkconv (TYINT, fixtype
  528.                     (cpexpr (dp->baseoffset)))));
  529.                 out_and_free_statement (outfile, tp);
  530.             } else {
  531.                 tp = prune_left_conv (mkexpr (OPMINUSEQ,
  532.                     mkconv (TYADDR, (expptr)p->datap),
  533.                     mkconv (TYINT, fixtype
  534.                     (mkexpr (OPSTAR, cpexpr (dp -> baseoffset),
  535.                     cpexpr (q -> vleng))))));
  536.                 out_and_free_statement (outfile, tp);
  537.             } /* else */
  538.             } /* if dp -> baseoffset -> const */
  539.         } /* if !checksubs */
  540.  
  541.         if (addif) {
  542.             nice_printf(outfile, /*{*/ "}\n");
  543.             prev_tab(outfile);
  544.             }
  545.         }
  546.     }
  547.     if (wrote_comment)
  548.         nice_printf (outfile, "\n/* Function Body */\n");
  549.     if (ac)
  550.         free((char *)ac);
  551.     if (p0 != p1)
  552.         frchain(&p1);
  553. } /* prolog */
  554.